home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / scsh / syntax-helpers.scm < prev    next >
Text File  |  1995-10-28  |  8KB  |  232 lines
  1. ;;; Macro expanding procs for scsh.
  2. ;;; Written for Clinger/Rees explicit renaming macros.
  3. ;;; Needs name-export and receive-syntax S48 packages.
  4. ;;; Also needs scsh's utilities package (optional-arg & check-arg).
  5. ;;; Must be loaded into for-syntax package.
  6. ;;; Copyright (c) 1993 by Olin Shivers.
  7.  
  8. (define-syntax define-simple-syntax
  9.   (syntax-rules ()
  10.     ((define-simple-syntax (name . pattern) result)
  11.      (define-syntax name (syntax-rules () ((name . pattern) result))))))
  12.  
  13. (define (name? thing)
  14.   (or (symbol? thing)
  15.       (generated? thing)))
  16.  
  17. ;;; Debugging macro:
  18. (define-simple-syntax (assert exp)
  19.   (if (not exp) (error "Assertion failed" (quote exp))))
  20.  
  21. ;;; Some process forms and redirections are implicitly backquoted.
  22.  
  23. (define (backq form rename)
  24.   (list (rename 'quasiquote) form))     ; form -> `form
  25. (define (unq form rename)
  26.   (list (rename 'unquote) form))     ; form -> ,form
  27.  
  28. (define (make-backquoter rename)
  29.   (lambda (form) (list (rename 'quasiquote) form)))
  30. (define (make-unquoter rename)
  31.   (lambda (form) (list (rename 'unquote) form)))
  32.  
  33. ;; DEBLOCK maps an expression to a list of expressions, flattening BEGINS.
  34. ;; (deblock '(begin (begin 3 4) 5 6 (begin 7 8))) => (3 4 5 6 7 8)
  35.  
  36. (define (deblock exp rename compare)
  37.   (let ((%block (rename 'begin)))
  38.     (let deblock1 ((exp exp))
  39.       (if (and (pair? exp)
  40.            (name? (car exp))
  41.            (compare %block (car exp)))
  42.       (apply append (map deblock1 (cdr exp)))
  43.       (list exp)))))
  44.  
  45. ;; BLOCKIFY maps an expression list to a BEGIN form, flattening nested BEGINS.
  46. ;; (blockify '( (begin 3 4) 5 (begin 6) )) => (begin 3 4 5 6)
  47.  
  48. (define (blockify exps rename compare)
  49.   (let ((new-exps (apply append
  50.              (map (lambda (exp) (deblock exp rename compare))
  51.                   exps))))
  52.     (cond ((null? new-exps)
  53.        (error "Empty BEGIN" exps))
  54.       ((null? (cdr new-exps))    ; (begin exp) => exp
  55.        (car new-exps))
  56.       (else `(,(rename 'begin) . ,new-exps)))))
  57.  
  58. (define (thunkate code rename compare)
  59.   (let ((%lambda (rename 'lambda)))
  60.     `(,%lambda () ,@(deblock code rename compare))))
  61.  
  62. ;;; Process forms are rewritten into code that causes them to execute
  63. ;;; in the current process.
  64. ;;; (BEGIN . scheme-code)    => (STDIO->STDPORTS (LAMBDA () . scheme-code))
  65. ;;; (| pf1 pf2)            => (BEGIN (FORK/PIPE (LAMBDA () pf1-code))
  66. ;;;                                       pf2-code)
  67. ;;; (|+ conns pf1 pf2)        => (BEGIN
  68. ;;;                                  (FORK/PIPE+ `conns (LAMBDA () pf1-code))
  69. ;;;                                  pf2-code)
  70. ;;; (epf . epf)            => epf-code
  71. ;;; (prog arg1 ... argn)    => (APPLY EXEC-PATH `(prog arg1 ... argn))
  72. ;;; [note the implicit backquoting of PROG, ARG1, ...]
  73.  
  74. ;;; NOTE: | and |+ won't read into many Scheme's as a symbol. If your
  75. ;;; Scheme doesn't handle it, kill them, and just use the PIPE, PIPE+
  76. ;;; aliases.
  77.  
  78. (define (transcribe-process-form pf rename compare)
  79.   (if (and (list? pf) (pair? pf))
  80.       (case (car pf)
  81.     ((begin) (transcribe-begin-process-form (cdr pf) rename compare))
  82.  
  83.     ((epf)    (transcribe-extended-process-form (cdr pf) rename compare))
  84.  
  85.     ((pipe)    (transcribe-simple-pipeline (cdr pf) rename compare))
  86.     ((|)    (transcribe-simple-pipeline (cdr pf) rename compare))
  87.  
  88.     ((|+)    (let ((conns (backq (cadr pf) rename))
  89.               (pfs (cddr pf)))
  90.           (transcribe-complex-pipeline conns pfs rename compare)))
  91.     ((pipe+)(let ((conns (backq (cadr pf) rename))
  92.               (pfs (cddr pf)))
  93.           (transcribe-complex-pipeline conns pfs rename compare)))
  94.  
  95.     (else    (let ((%apply (rename 'apply))
  96.               (%exec-path (rename 'exec-path))
  97.               (pf (backq pf rename)))
  98.           `(,%apply ,%exec-path ,pf))))
  99.       (error "Illegal process form" pf)))
  100.  
  101.  
  102. (define (transcribe-begin-process-form body rename compare)
  103.   (let ((%with-stdio-ports* (rename 'with-stdio-ports*))
  104.     (%lambda          (rename 'lambda)))
  105.     `(,%with-stdio-ports* (,%lambda () . ,body))))
  106.  
  107.  
  108. (define (transcribe-simple-pipeline pfs rename compare)
  109.   (if (null? pfs) (error "Empty pipeline")
  110.       (let* ((%fork/pipe (rename 'fork/pipe))
  111.          (trans-pf (lambda (pf)
  112.               (transcribe-process-form pf rename compare)))
  113.          (chunks (reverse (map trans-pf pfs)))
  114.          (last-chunk (car chunks))
  115.          (first-chunks (reverse (cdr chunks)))
  116.          (forkers (map (lambda (chunk)
  117.                  `(,%fork/pipe ,(thunkate chunk rename compare)))
  118.                first-chunks)))
  119.     (blockify `(,@forkers ,last-chunk) rename compare))))
  120.  
  121.  
  122. ;;; Should let-bind CONNS in case it's a computed form.
  123.  
  124. (define (transcribe-complex-pipeline conns pfs rename compare)
  125.   (if (null? pfs) (error "Empty pipeline")
  126.       (let* ((%fork/pipe+ (rename 'fork/pipe+))
  127.          (trans-pf (lambda (pf)
  128.              (transcribe-process-form pf rename compare)))
  129.          (chunks (reverse (map trans-pf pfs)))
  130.          (last-chunk (car chunks))
  131.          (first-chunks (reverse (cdr chunks)))
  132.          (forkers (map (lambda (chunk)
  133.                  `(,%fork/pipe+ ,conns
  134.                         ,(thunkate chunk rename compare)))
  135.                first-chunks)))
  136.     (blockify `(,@forkers ,last-chunk) rename compare))))
  137.       
  138.  
  139. (define (transcribe-extended-process-form epf rename compare)
  140.   (let* ((pf (car epf))        ; First form is the process form.
  141.      (redirs (cdr epf))     ; Others are redirection forms.
  142.      (trans-redir (lambda (r) (transcribe-redirection r rename compare)))
  143.      (redir-chunks (map trans-redir redirs))
  144.      (pf-chunk (transcribe-process-form pf rename compare)))
  145.     (blockify `(,@redir-chunks ,pf-chunk) rename compare)))
  146.  
  147.  
  148.  
  149. ;;; These two utility funs are for parsing optional last arguments,
  150. ;;; e.g. the PORT arg in
  151. ;;;    (write-string string [port])
  152. ;;;    (define (write-string str . maybe-port) ...).
  153.  
  154. (define (optional-arg maybe-arg default)
  155.   (cond ((null? maybe-arg) default)
  156.     ((null? (cdr maybe-arg))  (car maybe-arg))
  157.     (else (error "too many optional arguments" maybe-arg))))
  158.  
  159.  
  160. (define (optional-arg* maybe-arg default-thunk)
  161.   (if (null? maybe-arg) (default-thunk) (car maybe-arg)))
  162.  
  163.  
  164. (define (check-arg pred val caller)
  165.   (let lp ((val val))
  166.     (if (pred val) val
  167.     (lp (error "Bad argument" val))))) ; Loop doesn't really work.
  168.  
  169.  
  170. (define (transcribe-redirection redir rename compare)
  171.   (let* ((backq (make-backquoter rename))
  172.      (parse-spec (lambda (x default-fdes) ; Parse an ([fdes] arg) form.
  173.                ;; X  must be a list of 1 or 2 elts.
  174.                (check-arg (lambda (x) (and (list? x)
  175.                            (< 0 (length x) 3)))
  176.                   x transcribe-redirection)
  177.                (let ((a (car x))
  178.                  (b (cdr x)))
  179.              (if (null? b) (values default-fdes (backq a))
  180.                  (values (backq a) (backq (car b)))))))
  181.      (oops (lambda () (error "unknown i/o redirection" redir)))
  182.      (%open (rename 'shell-open))
  183. ;     (%dup-port (rename 'dup-port))
  184.      (%dup->fdes (rename 'dup->fdes))
  185. ;     (%run/port (rename 'run/port))
  186.      (%open-string-source (rename 'open-string-source))
  187.      (%open/create+trunc (rename 'open/create+trunc))
  188.      (%open/write+append+create (rename 'open/write+append+create))
  189.      (%q (lambda (x) (list (rename 'quote) x)))
  190.      (%close (rename 'close))
  191.      (%move->fdes (rename 'move->fdes))
  192.      (%stdports->stdio (rename 'stdports->stdio)))
  193.     (cond ((pair? redir)
  194.        (let ((args (cdr redir)))
  195.          (case (car redir)
  196.            ((<)
  197.         (receive (fdes fname) (parse-spec args 0)
  198.           `(,%open ,fname 0 ,fdes)))
  199.  
  200.            ((>)
  201.         (receive (fdes fname) (parse-spec args 1)
  202.           `(,%open ,fname ,%open/create+trunc ,fdes)))
  203.  
  204.            ;;; BUG BUG -- EPF is backquoted by parse-spec.
  205. ;           ((<<<) ; Just a RUN/PORT with a specific target fdes.
  206. ;        (receive (fdes epf) (parse-spec args 0)
  207. ;          `(,%dup-port (,%run/port . ,epf) ,fdes))) ; Add a WITH-PORT.
  208.  
  209.            ((<<)
  210.         (receive (fdes exp) (parse-spec args 0)
  211.           `(,%move->fdes (,%open-string-source ,exp) ,fdes)))
  212.  
  213.            ((>>)
  214.         (receive (fdes fname) (parse-spec args 1)
  215.           `(,%open ,fname ,%open/write+append+create ,fdes)))
  216.  
  217.            ((=)
  218.         (assert (= 2 (length args))) ; Syntax check.
  219.         `(,%dup->fdes ,(backq (cadr args)) ,(backq (car args))))
  220.  
  221.            ((-)    ; (- fdes) => close the fdes.
  222.         (assert (= 1 (length args))) ; Syntax check.
  223.         `(,%close ,(backq (car args))))
  224.  
  225.            (else (oops)))))
  226.  
  227.       ((eq? redir 'stdports)
  228.        `(,%stdports->stdio))
  229.       (else (oops)))))
  230.  
  231. ;;; <<< should be {
  232.